home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / forst.zoo / forst / lib / floats.s < prev    next >
Encoding:
Text File  |  1990-12-10  |  3.0 KB  |  171 lines
  1. : module ;
  2.  
  3. hex
  4. : q/  { 2 regargs num den }
  5.   0 num den 0  ud/mod  2swap 2drop ;
  6.  
  7. : align   { 3 regargs lo hi exponent }
  8.   ( double mantissa)
  9.   hi lo or
  10.   if
  11.     begin
  12.       hi ff800000 and  0=
  13.     while
  14.       lo 2* to lo
  15.       hi rol to hi
  16.       -1 addto exponent
  17.     repeat
  18.     lo 0<
  19.     if 1 addto hi then  ( round up)
  20.     hi 1000000 < not    ( overshot?)
  21.     if
  22.       hi 2/ to hi
  23.       1 addto exponent
  24.     then
  25.   then
  26.   hi exponent  ( mantissa,exponent)
  27. ;
  28.  
  29. : expon  17 lsr  0ff and 7f - ;
  30. : mant  7fffff and 800000 or ;
  31. : smant  dup mant  swap 0< if negate then ;
  32.  
  33. : pack  { 2 regargs mantiss exp }
  34.   mantiss
  35.   if
  36.     exp 7e >        ( decimal 37)
  37.     if  7fffffff    ( infinity because overflow)
  38.     else
  39.       exp -7f <        ( decimal -37)
  40.       if  0        ( zero because underflow)
  41.       else
  42.         mantiss abs 7fffff and
  43.         exp 7f + 0ff and wflip 7 lsl  or
  44.       then
  45.     then
  46.   else 0        ( because a zero mantissa)
  47.   then ;
  48.  
  49. : fnegate  dup 0= not  if  80000000 xor then ;
  50. : fabs  7fffffff and ;
  51.  
  52. : f*  { 2 regargs fn1 fn2 }
  53.   fn1 0= fn2 0= or
  54.   if 0  ( zero product)
  55.   else
  56.     fn1 mant fn2 mant um*  ( mantissa product)
  57.     fn1 expon fn2 expon + 9 +  align  pack
  58.     fn1 fn2 xor 0<
  59.     if fnegate then  ( real product)
  60.   then ;
  61.  
  62. : f/ { 2 regargs num den }
  63.  
  64.   den 0=
  65.   if  7fffffff  exit then  ( infinity)
  66.   num 0=
  67.   if  0  exit then         ( zero)
  68.  
  69.   num mant den mant q/  ( mantissa quotient)
  70.   num expon den expon -  17 + align  pack
  71.   num den xor 0<
  72.   if fnegate then          ( real quotient)
  73. ;
  74.  
  75. : +mants { 3 regargs #shifts bigger smaller }
  76.  
  77.   #shifts 17 >
  78.   if
  79.     bigger smant
  80.   else
  81.     smaller smant #shifts asr
  82.     bigger smant +
  83.   then ( mantissa)
  84. ;
  85.  
  86. : f+  { 2 regargs fn1 fn2  3 regs diff exponent fsign }
  87.  
  88.   fn1 0= if  fn2  exit then
  89.   fn2 0= if  fn1  exit then
  90.  
  91.   fn1 expon  fn2 expon  -  to diff
  92.   fn1 expon to exponent
  93.  
  94.   diff
  95.   if
  96.     diff 0>
  97.     if
  98.       diff fn1 fn2
  99.     else
  100.       fn2 expon to exponent
  101.       diff abs fn2 fn1
  102.     then
  103.     +mants
  104.   else
  105.     fn1 smant fn2 smant +
  106.   then
  107.  
  108.   dup 0= if exit then
  109.   dup to fsign  abs
  110.  
  111.   dup 800000 <
  112.   if
  113.     begin
  114.       2*  -1 addto exponent
  115.       dup 800000 and
  116.     until
  117.   else
  118.     begin
  119.       dup ff000000 and
  120.     while
  121.       2/  1 addto exponent
  122.     repeat
  123.   then
  124.  
  125.   exponent pack
  126.   fsign 0<
  127.   if fnegate then ( real sum)
  128. ;
  129.  
  130. : f-  fnegate f+ ;
  131.  
  132. : i>f  { 1 regarg numb }
  133.   numb 0=
  134.   if 0
  135.   else
  136.     numb abs 0  37 align  pack
  137.     numb 0<
  138.     if fnegate then
  139.   then ;
  140.  
  141. : f>i { 1 regarg fno  1 reg exponent }
  142.   fno 0=
  143.   if 0
  144.   else
  145.     fno expon to exponent
  146.     exponent 0<
  147.     if
  148.       0
  149.     else
  150.       8 addto exponent
  151.       fno mant 0
  152.       begin
  153.         d2*  -1 addto exponent
  154.         exponent 0<
  155.       until
  156.       swap drop
  157.       fno 0<  if negate then
  158.     then
  159.   then
  160. ;
  161.  
  162. 1 i>f constant f1.0
  163. 0a i>f constant f10.0
  164. f1.0 f10.0 f/ constant f0.1
  165. f1.0 2 i>f f/ constant f0.5
  166.  
  167. : fix  f>i i>f ;
  168. : int  dup fabs  f0.5 f+ fix
  169.   swap 0< if fnegate then ;
  170. : fmod  2dup f/ fix f* f- ;
  171.